home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist01.zoo / lsp / common.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1990-11-09  |  1.9 KB  |  79 lines
  1. ;; functions missing that are part of common lisp, and commonly used
  2.  
  3. ;; push and pop treat variable v as a stack
  4.  
  5. (defmacro push (v l)
  6.     `(setf ,l (cons ,v ,l)))
  7.  
  8. (defmacro pop (l)
  9.     `(prog1 (first ,l) (setf ,l (rest ,l))))
  10.  
  11. ;; pairlis does not check for lengths of keys and values being unequal
  12.  
  13. (defun pairlis (keys values list)
  14.     (do ((remkeys keys (rest remkeys))
  15.      (remvals values (rest remvals))
  16.      (newalist list
  17.            (cons (cons (first remkeys) (first remvals)) newalist)))
  18.     ((null remkeys) newalist)
  19.      ))
  20.  
  21.  
  22. (defun copy-list (list) (append list 'nil))
  23.  
  24. (defun copy-alist (list)
  25.     (if (null list)
  26.         'NIL
  27.         (cons (if (consp (car list))
  28.           (cons (caar list) (cdar list))
  29.           (car list))
  30.           (my-copy-alist (cdr list)))))
  31.  
  32. (defun copy-tree (list)
  33.     (if (consp list)
  34.         (cons (copy-tree (car list)) (copy-tree (cdr list)))
  35.         list))
  36.  
  37. (defun list* (&rest list)
  38.     (cond ((null list) 'nil)
  39.       ((null (cdr list)) (car list))
  40.       (t (do* ((head (cons (car list) 'nil))
  41.            (current head
  42.                 (cdr (rplacd current (cons (car tail) 'nil))))
  43.            (tail (cdr list) (cdr tail)))
  44.           ((null (cdr tail)) (rplacd current (car tail)) head)
  45.           ))))
  46.  
  47. ;; THE CAR OF A TCONC POINTS TO THE TCONC LIST,
  48. ;; THE TAIL POINTS TO LAST ELEMENT
  49.  
  50. (defun make-tconc nil
  51.     (cons 'nil 'nil))
  52.  
  53. (defun tconc (tc new)
  54.     (let ((newl (cons new 'nil)))
  55.       (if (null (cdr tc))
  56.       (rplaca tc newl)
  57.       (rplacd (cdr tc) newl))
  58.       (rplacd tc newl)
  59.       tc))
  60.  
  61. (defun lconc (tc list)
  62.     (cond ((not (null list))
  63.        (if (null (cdr tc))
  64.            (rplaca tc list)
  65.            (rplacd (cdr tc) list))
  66.        (rplacd tc (last list))))
  67.     tc)
  68.  
  69. (defun remove-head (tc)
  70.     (cond ((null (car tc)) 'nil)
  71.       ((null (cdar tc))
  72.        (let ((element (caar tc)))
  73.          (rplaca tc 'nil)
  74.          (rplacd tc 'nil)
  75.          element))
  76.       (t (let ((element (caar tc)))
  77.            (rplaca tc (cdar tc))
  78.            element))))
  79.